home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / type-parser.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.9 KB  |  115 lines  |  [TEXT/CCL2]
  1. ;;; File: type-parser        Author: John
  2.  
  3. (define (parse-type)
  4.   (let ((type (parse-btype)))
  5.     (token-case
  6.       (->
  7.        (**tycon/def (core-symbol "Arrow") (list type (parse-type))))
  8.       (else type))))
  9.  
  10. (define (parse-btype)
  11.   (token-case
  12.    (tycon (let* ((tycon (tycon->ast))
  13.          (tycon-args (parse-atype-list)))
  14.         (setf (tycon-args tycon) tycon-args)
  15.         tycon))
  16.    (else
  17.     (parse-atype))))
  18.  
  19. (define (parse-atype-list)
  20.   (token-case
  21.     (atype-start
  22.      (let ((atype (parse-atype)))
  23.        (cons atype (parse-atype-list))))
  24.     (else '())))
  25.  
  26. (define (parse-atype)
  27.   (token-case
  28.     (tyvar (tyvar->ast))
  29.     (tycon (tycon->ast))
  30.     (\( (token-case
  31.       (\) (**tycon/def (core-symbol "UnitType") '()))
  32.       (else
  33.         (let ((type (parse-type)))
  34.           (token-case
  35.            (\) type)
  36.            (\, (let ((types  (cons type (parse-type-list))))
  37.              (**tycon/def (tuple-tycon (length types)) types)))
  38.            (else
  39.         (signal-missing-token "`)' or `,'" "type expression")))))))
  40.     (\[ (let ((type (parse-type)))
  41.       (require-token \] (signal-missing-token "`]'" "type expression"))
  42.       (**tycon/def (core-symbol "List") (list type))))
  43.     (else
  44.      (signal-invalid-syntax "an atype"))))
  45.  
  46. (define (parse-type-list)
  47.   (let ((type (parse-type)))
  48.     (token-case (\, (cons type (parse-type-list)))
  49.         (\) (list type))
  50.         (else (signal-missing-token "`)' or `,'" "type expression")))))
  51.  
  52. ;;; This is used to determine whether a type is preceded by a context
  53.  
  54. (define (has-optional-context?)
  55.   (let* ((saved-excursion (save-scanner-state))
  56.      (res (token-case
  57.         (conid    
  58.          (token-case
  59.           (varid (eq-token? '=>))
  60.           (else '#f)))
  61.         (\( (scan-context))
  62.         (else '#f))))
  63.     (restore-excursion saved-excursion)
  64.     res))
  65.  
  66. (define (scan-context)
  67.   (token-case
  68.     (conid
  69.      (token-case
  70.        (varid
  71.      (token-case
  72.        (\) (eq-token? '=>))
  73.        (\, (scan-context))
  74.        (else '#f)))
  75.        (else '#f)))
  76.     (else '#f)))
  77.  
  78. (define (parse-context)
  79.  (let ((contexts (token-case
  80.                (tycon
  81.             (list (parse-single-context)))
  82.            (\( (parse-contexts))
  83.            (else
  84.             (signal-invalid-syntax "a context")))))
  85.    (require-token => (signal-missing-token "`=>'" "context"))
  86.    contexts))
  87.  
  88. (define (parse-single-context)
  89.   (let ((class (class->ast)))
  90.     (token-case
  91.       (tyvar
  92.        (let ((tyvar (token->symbol)))
  93.      (make context (class class) (tyvar tyvar))))
  94.       (else (signal-missing-token "<tyvar>" "class assertion")))))
  95.  
  96. (define (parse-contexts)
  97.   (token-case
  98.     (tycon (let ((context (parse-single-context)))
  99.           (token-case
  100.         (\, (cons context (parse-contexts)))
  101.         (\) (list context))
  102.         (else (signal-missing-token "`)' or `,'" "context")))))
  103.     (else (signal-missing-token "<tycon>" "class assertion"))))
  104.  
  105. (define (parse-optional-context)
  106.   (if (has-optional-context?)
  107.       (parse-context)
  108.       '()))
  109.  
  110. (define (parse-signature)
  111.   (let* ((contexts (parse-optional-context))
  112.      (type (parse-type)))
  113.     (make signature (context contexts) (type type))))
  114.  
  115.